perm filename DISKO.FOR[ZZZ,LCS] blob sn#439875 filedate 1979-05-08 generic text, type T, neo UTF8
C****** DISKO, CLOSIT, BLOCK DATA (DSK CHANNELS), PACKER, PACKX ******
  	SUBROUTINE DISKO(N,RNAM,J)
C N=DEVICE NUMBER, RNAM=FILE NAME, J=0=OUTPUT, =-1=INPUT
C J=1=UNFORMATTED IN, =2=UNFORMATTED OUT
C J=3=FORMATTED IN,   =4=FORMATTED OUT
	GO TO (1,2,3,4)J 

CC1        CALL IFILE(N,RNAM)
1  	CALL OPEN(N,RNAM,0,'RDO',,,'UNF')
	RETURN
CC2        CALL OFILE(N,RNAM)
2  	CALL OPEN(N,RNAM,0,'NEW',,,'UNF')
	RETURN
CC3        CALL IFILE(N,RNAM)
3  	CALL OPEN(N,RNAM,0,'RDO',,,'FOR')
	RETURN
CC4        CALL OFILE(N,RNAM)
4  	CALL OPEN(N,RNAM,0,'NEW',,,'FOR')
	RETURN
	END

	SUBROUTINE CLOSIT(IDEV)
   	CALL CLOSE(IDEV)
CC	ENDFILE IDEV
	END

	BLOCK DATA
	COMMON /DEVS/ID1,ID21,JTYPE,ID23,ID20
	DATA JTYPE/5/,ID23/23/,ID20/20/,ID1/1/,ID21/21/
	END

	SUBROUTINE PACKER(RNAM,INP)
	DIMENSION INP(1),KNM(5)
	DATA IBLA/' '/,ISEMI/';'/,IEQU/'='/
CCC	DATA IBLA/' '/,ISEMI/';'/,IARO/"575004020100/,IEQU/'='/
C ABOVE FOR PDP10 ONLY*********
C N=WDCNT 
C****** THE BIG NUMBER=LEFT ARROW

	DO 1 J=1,80
	N=INP(J)
	IF(N.EQ.IEQU)GO TO 2
CCC	IF(N.EQ.IARO.OR.N.EQ.IEQU)GO TO 2
1	IF(N.EQ.IBLA.OR.N.EQ.ISEMI)GO TO 2
2	II=J
	J=J-1
	N=J
	IF(J.GT.4)N=4
4	DO 10 K=1,4
	IF(K.GT.N)GO TO 11
	KNM(K)=INP(K)
	GO TO 10
11	KNM(K)=IBLA
10	CONTINUE
	CALL PACKX(RNAM,KNM)
	RETURN
	END

CC	SUBROUTINE PACKX(NAM,KNM)
CC	DIMENSION KNM(5)
CC	DATA KK/128/,LL/"377777777777/,JJ/"2000000000/
CC	1 , MM/"774000000000/,IBLA/' '/
CC	KNM(5)=IBLA
C  BECAUSE 5 CHARS IN PDP10 WORD.
CC	NAM=0
CC	DO 12 K=5,1,-1
CC	NAM=NAM .OR. (KNM(K) .AND. MM)
CC	IF (K.EQ.1)RETURN
CC17	IF (NAM.GE.0)GO TO 13
CC	NAM = (( NAM .AND. LL)/KK) .OR. JJ
CC	GO TO 12
CC13	NAM = NAM / KK
CC12	CONTINUE
CC	RETURN
CC	END

	SUBROUTINE PACKX(A4RET,KPAC)
	DIMENSION KPAC(1)
	LOGICAL*1 A4RET(4)
	DO 1 K=1,4
 1	A4RET(K)=KPAC(K)
C PACKS 4 CHARS. INTO SINGLE, REAL WORD (4 BYTES)
	RETURN
	END